home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / PRIMUTL.C < prev    next >
C/C++ Source or Header  |  1992-05-28  |  17KB  |  645 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/primutl.c,v 9.56 1992/05/28 19:03:07 jinx Exp $
  4.  
  5. Copyright (c) 1988-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* 
  36.  * This file contains the support routines for mapping primitive names
  37.  * to numbers within the microcode.  Primitives are written in C
  38.  * and available in Scheme, but not always present in all versions of
  39.  * the interpreter.  Thus, these objects are always referenced
  40.  * externally by name and converted to numeric references only for the
  41.  * duration of a single Scheme session.
  42.  */
  43.  
  44. #include "scheme.h"
  45. #include "prims.h"
  46. #include <ctype.h>
  47.  
  48. SCHEME_OBJECT Undefined_Primitives = SHARP_F;
  49. SCHEME_OBJECT Undefined_Primitives_Arity = SHARP_F;
  50.  
  51. /* Common utilities. */
  52.  
  53. extern int EXFUN (strcmp_ci, (char *, char *));
  54.  
  55. int
  56. DEFUN (strcmp_ci, (s1, s2), fast char * s1 AND fast char * s2)
  57. {
  58.   int length1 = (strlen (s1));
  59.   int length2 = (strlen (s2));
  60.   fast int length = ((length1 < length2) ? length1 : length2);
  61.  
  62.   while ((length--) > 0)
  63.     {
  64.       fast int c1 = (*s1++);
  65.       fast int c2 = (*s2++);
  66.       if (islower (c1)) c1 = (toupper (c1));
  67.       if (islower (c2)) c2 = (toupper (c2));
  68.       if (c1 < c2) return (-1);
  69.       if (c1 > c2) return (1);
  70.     }
  71.   return (length1 - length2);
  72. }
  73.  
  74. struct primitive_alias
  75.   {
  76.     char *alias;
  77.     char *name;
  78.   };
  79.  
  80. #include "prename.h"
  81.  
  82. static char *
  83. DEFUN (primitive_alias_to_name, (alias), char * alias)
  84. {
  85.   fast struct primitive_alias *alias_ptr;
  86.   fast struct primitive_alias *alias_end;
  87.  
  88.   alias_ptr = aliases;
  89.   alias_end = (alias_ptr + N_ALIASES);
  90.   while (alias_ptr < alias_end)
  91.     {
  92.       if ((strcmp_ci (alias, (alias_ptr -> alias))) == 0)
  93.     return (alias_ptr -> name);
  94.       alias_ptr += 1;
  95.     }
  96.   return (alias);
  97. }
  98.  
  99. /*
  100.   In primitive_name_to_code, size is really 1 less than size.
  101.   It is really the index of the last valid entry.
  102.  */
  103.  
  104. #if FALSE
  105.  
  106. /* This version performs an expensive linear search. */
  107.  
  108. long
  109. DEFUN (primitive_name_to_code, (name, table, size),
  110.        char * name AND char * table[] AND int size)
  111. {
  112.   fast int i;
  113.  
  114.   name = (primitive_alias_to_name (name));
  115.   for (i = size; i >= 0; i -= 1)
  116.   {
  117.     fast char *s1, *s2;
  118.  
  119.     s1 = name;
  120.     s2 = table[i];
  121.  
  122.     while (*s1++ == *s2)
  123.     {
  124.       if (*s2++ == '\0')
  125.       {
  126.     return ((long) i);
  127.       }
  128.     }
  129.   }
  130.   return ((long) (-1));
  131. }
  132.  
  133. #else /* not FALSE */
  134.  
  135. /* This version performs a log (base 2) search.
  136.    The table is assumed to be ordered alphabetically.
  137.  */
  138.  
  139. long
  140. DEFUN (primitive_name_to_code, (name, table, size),
  141.        char * name AND fast char *table[] AND int size)
  142. {
  143.   fast int low, high, middle, result;
  144.  
  145.   name = (primitive_alias_to_name (name));
  146.   low = 0;
  147.   high = size;
  148.  
  149.   while(low < high)
  150.   {
  151.     middle = ((low + high) / 2);
  152.     result = strcmp_ci (name, table[middle]);
  153.     if (result < 0)
  154.     {
  155.       high = (middle - 1);
  156.     }
  157.     else if (result > 0)
  158.     {
  159.       low = (middle + 1);
  160.     }
  161.     else
  162.     {
  163.       return ((long) middle);
  164.     }
  165.   }
  166.  
  167.   /* This takes care of the fact that division rounds down.
  168.      If division were to round up, we would have to use high.
  169.    */
  170.  
  171.   if (strcmp_ci(name, table[low]) == 0)
  172.   {
  173.     return ((long) low);
  174.   }
  175.   return ((long) -1);
  176. }
  177.  
  178. #endif /* false */
  179.  
  180. long
  181. DEFUN (primitive_code_to_arity, (number), long number)
  182. {
  183.   if (number <= MAX_PRIMITIVE)
  184.   {
  185.     return ((long) Primitive_Arity_Table[number]);
  186.   }
  187.   else
  188.   {
  189.     SCHEME_OBJECT entry;
  190.     long arity;
  191.  
  192.     entry = VECTOR_REF (Undefined_Primitives_Arity, (number - MAX_PRIMITIVE));
  193.     if (entry == SHARP_F)
  194.     {
  195.       return ((long) UNKNOWN_PRIMITIVE_ARITY);
  196.     }
  197.     else
  198.     {
  199.       arity = FIXNUM_TO_LONG (entry);
  200.     }
  201.     return (arity);
  202.   }
  203. }
  204.  
  205. char *
  206. DEFUN (primitive_code_to_documentation, (number), long number)
  207. {
  208.   return
  209.     ((number > MAX_PRIMITIVE)
  210.      ? ((char *) 0)
  211.      : (Primitive_Documentation_Table [number]));
  212. }
  213.  
  214. /* Externally visible utilities */
  215.  
  216. extern SCHEME_OBJECT EXFUN (make_primitive, (char *));
  217. extern SCHEME_OBJECT EXFUN
  218.   (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int));
  219. extern SCHEME_OBJECT
  220. EXFUN (search_for_primitive,
  221.        (SCHEME_OBJECT scheme_name AND char * c_name
  222.         AND Boolean intern_p AND Boolean allow_p AND int arity));
  223.  
  224. SCHEME_OBJECT
  225. DEFUN (make_primitive, (name), char * name)
  226. {
  227.  
  228.   return (search_for_primitive(SHARP_F, name, true, true,
  229.                    UNKNOWN_PRIMITIVE_ARITY));
  230. }
  231.  
  232. SCHEME_OBJECT
  233. DEFUN (find_primitive, (name, intern_p, allow_p, arity),
  234.        SCHEME_OBJECT name
  235.        AND Boolean intern_p AND Boolean allow_p
  236.        AND int arity)
  237. {
  238.  
  239.   return (search_for_primitive(name, (STRING_LOC (name, 0)),
  240.                    intern_p, allow_p, arity));
  241. }
  242.  
  243. extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT));
  244.  
  245. long
  246. DEFUN (primitive_to_arity, (primitive), SCHEME_OBJECT primitive)
  247. {
  248.   return (primitive_code_to_arity(PRIMITIVE_NUMBER(primitive)));
  249. }
  250.  
  251. extern char * EXFUN (primitive_to_documentation, (SCHEME_OBJECT));
  252.  
  253. char *
  254. DEFUN (primitive_to_documentation, (primitive), SCHEME_OBJECT primitive)
  255. {
  256.   return (primitive_code_to_documentation (PRIMITIVE_NUMBER (primitive)));
  257. }
  258.  
  259. extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT));
  260.  
  261. /*
  262.   This is only valid during the invocation of a primitive.
  263.   It is used by various utilities to back out of code.
  264.  */
  265.  
  266. long
  267. DEFUN (primitive_to_arguments, (primitive), SCHEME_OBJECT primitive)
  268. {
  269.   long arity;
  270.  
  271.   arity = primitive_code_to_arity(PRIMITIVE_NUMBER(primitive));
  272.  
  273.   if (arity == ((long) LEXPR_PRIMITIVE_ARITY))
  274.   {
  275.     arity = ((long) Regs[REGBLOCK_LEXPR_ACTUALS]);
  276.   }
  277.   return (arity);
  278. }
  279.  
  280. char *
  281. DEFUN (primitive_code_to_name, (code), int code)
  282. {
  283.   char *string;
  284.  
  285.   if (code <= MAX_PRIMITIVE)
  286.   {
  287.     string = Primitive_Name_Table[code];
  288.   }
  289.   else
  290.   {
  291.     /* NOTE:
  292.        This is invoked by cons_primitive_table which is invoked by
  293.        fasdump before the "fixups" are undone.  This means that the scheme
  294.        string may actually have a broken heart as its first word, but
  295.        this code will still work because the characters will still be there.
  296.      */
  297.  
  298.     SCHEME_OBJECT scheme_string;
  299.  
  300.     scheme_string =
  301.       (VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE)));
  302.     string = ((char *) (STRING_LOC (scheme_string, 0)));
  303.   }
  304.   return (string);
  305. }
  306.  
  307. extern char *EXFUN (primitive_to_name, (SCHEME_OBJECT));
  308.  
  309. char *
  310. DEFUN (primitive_to_name, (primitive), SCHEME_OBJECT primitive)
  311. {
  312.   return (primitive_code_to_name(PRIMITIVE_NUMBER(primitive)));
  313. }
  314.  
  315. /* this avoids some consing. */
  316.  
  317. SCHEME_OBJECT
  318. DEFUN (primitive_name, (code), int code)
  319. {
  320.   SCHEME_OBJECT scheme_string;
  321.  
  322.   if (code <= MAX_PRIMITIVE)
  323.   {
  324.     scheme_string =
  325.       (char_pointer_to_string ((unsigned char *) Primitive_Name_Table[code]));
  326.   }
  327.   else
  328.   {
  329.     scheme_string =
  330.       (VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE)));
  331.   }
  332.   return (scheme_string);
  333. }
  334.  
  335. /*
  336.   scheme_name can be #F, meaning cons up from c_name as needed.
  337.   c_name must always be provided.
  338.  */
  339.  
  340. SCHEME_OBJECT
  341. DEFUN (search_for_primitive,
  342.        (scheme_name, c_name, intern_p, allow_p, arity),
  343.        SCHEME_OBJECT scheme_name AND char * c_name
  344.        AND Boolean intern_p AND Boolean allow_p
  345.        AND int arity)
  346. {
  347.   long i, Max, old_arity;
  348.   SCHEME_OBJECT *Next;
  349.  
  350.   i = primitive_name_to_code(c_name,
  351.                  &Primitive_Name_Table[0],
  352.                  MAX_PRIMITIVE);
  353.   if (i != -1)
  354.   {
  355.     old_arity = Primitive_Arity_Table[i];
  356.     if ((arity == UNKNOWN_PRIMITIVE_ARITY) || (arity == old_arity))
  357.     {
  358.       return (MAKE_PRIMITIVE_OBJECT(0, i));
  359.     }
  360.     else
  361.     {
  362.       return (LONG_TO_FIXNUM(old_arity));
  363.     }
  364.   }
  365.   /* Search the undefined primitives table if allowed. */
  366.  
  367.   if (!allow_p)
  368.   {
  369.     return (SHARP_F);
  370.   }
  371.  
  372.   /* The vector should be sorted for faster comparison. */
  373.  
  374.   Max = NUMBER_OF_UNDEFINED_PRIMITIVES();
  375.   if (Max > 0)
  376.   {
  377.     Next = MEMORY_LOC (Undefined_Primitives, 2);
  378.  
  379.     for (i = 1; i <= Max; i++)
  380.     {
  381.       SCHEME_OBJECT temp;
  382.  
  383.       temp = *Next++;
  384.       if (strcmp_ci (c_name, ((char *) (STRING_LOC (temp, 0)))) == 0)
  385.       {
  386.     if (arity != UNKNOWN_PRIMITIVE_ARITY)
  387.     {
  388.       temp = VECTOR_REF (Undefined_Primitives_Arity, i);
  389.       if (temp == SHARP_F)
  390.         VECTOR_SET
  391.           (Undefined_Primitives_Arity, i, (LONG_TO_FIXNUM (arity)));
  392.       else
  393.       {
  394.         old_arity = FIXNUM_TO_LONG (temp);
  395.         if (arity != old_arity)
  396.         {
  397.           return (temp);
  398.         }
  399.       }
  400.     }
  401.     return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + i), (MAX_PRIMITIVE + 1)));
  402.       }
  403.     }
  404.   }
  405.  
  406.   /*
  407.     Intern the primitive name by adding it to the vector of
  408.     undefined primitives, if interning is allowed.
  409.    */
  410.  
  411.   if (!intern_p)
  412.   {
  413.     return (SHARP_F);
  414.   }
  415.  
  416.   if (scheme_name == SHARP_F)
  417.   {
  418.     scheme_name = (char_pointer_to_string ((unsigned char *) c_name));
  419.   }
  420.  
  421.   if ((Max % CHUNK_SIZE) == 0)
  422.     {
  423.       if (Max > 0)
  424.     Next = (MEMORY_LOC (Undefined_Primitives, 2));
  425.       Undefined_Primitives =
  426.     (allocate_marked_vector (TC_VECTOR, (Max + CHUNK_SIZE + 1), true));
  427.       FAST_VECTOR_SET
  428.     (Undefined_Primitives, 0, (LONG_TO_UNSIGNED_FIXNUM (Max + 1)));
  429.       for (i = 0; (i < Max); i += 1)
  430.     FAST_VECTOR_SET
  431.       (Undefined_Primitives, (i + 1), (MEMORY_FETCH (*Next++)));
  432.       FAST_VECTOR_SET (Undefined_Primitives, (Max + 1), scheme_name);
  433.       for (i = 1; (i < CHUNK_SIZE); i += 1)
  434.     FAST_VECTOR_SET (Undefined_Primitives, (i + Max + 1), SHARP_F);
  435.  
  436.       if (Max > 0)
  437.     Next = (MEMORY_LOC (Undefined_Primitives_Arity, 2));
  438.       Undefined_Primitives_Arity =
  439.     (allocate_marked_vector (TC_VECTOR, (Max + CHUNK_SIZE + 1), true));
  440.       FAST_VECTOR_SET (Undefined_Primitives_Arity, 0, SHARP_F);
  441.       for (i = 0; (i < Max); i += 1)
  442.     FAST_VECTOR_SET
  443.       (Undefined_Primitives_Arity, (i + 1), (MEMORY_FETCH (*Next++)));
  444.       FAST_VECTOR_SET
  445.     (Undefined_Primitives_Arity,
  446.      (Max + 1),
  447.      ((arity != UNKNOWN_PRIMITIVE_ARITY)
  448.       ? (LONG_TO_FIXNUM (arity))
  449.       : SHARP_F));
  450.       for (i = 1; (i < CHUNK_SIZE); i += 1)
  451.     FAST_VECTOR_SET (Undefined_Primitives_Arity, (i + Max + 1), SHARP_F);
  452.  
  453.       Max += 1;
  454.     }
  455.   else
  456.   {
  457.     Max += 1;
  458.     VECTOR_SET (Undefined_Primitives, Max, scheme_name);
  459.     if (arity != UNKNOWN_PRIMITIVE_ARITY)
  460.     {
  461.       VECTOR_SET (Undefined_Primitives_Arity, Max, (LONG_TO_FIXNUM (arity)));
  462.     }
  463.     VECTOR_SET (Undefined_Primitives, 0, (LONG_TO_UNSIGNED_FIXNUM(Max)));
  464.   }
  465.   return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + Max), (MAX_PRIMITIVE + 1)));
  466. }
  467.  
  468. /* Dumping and loading primitive object references. */
  469.  
  470. extern SCHEME_OBJECT
  471.   * load_renumber_table,
  472.   EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
  473.   * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
  474.   * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
  475.   * EXFUN (cons_whole_primitive_table,
  476.        (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  477.  
  478. extern void EXFUN (install_primitive_table,
  479.            (SCHEME_OBJECT *, long, Boolean));
  480.  
  481. SCHEME_OBJECT *load_renumber_table;
  482. static SCHEME_OBJECT *internal_renumber_table;
  483. static SCHEME_OBJECT *external_renumber_table;
  484. static long next_primitive_renumber;
  485.  
  486. SCHEME_OBJECT *
  487. DEFUN (initialize_primitive_table, (where, end),
  488.        fast SCHEME_OBJECT *where AND SCHEME_OBJECT *end)
  489. {
  490.   SCHEME_OBJECT *top;
  491.   fast long number_of_primitives;
  492.  
  493.   number_of_primitives = NUMBER_OF_PRIMITIVES();
  494.   top = &where[2 * number_of_primitives];
  495.   if (top < end)
  496.   {
  497.     internal_renumber_table = where;
  498.     external_renumber_table = &where[number_of_primitives];
  499.     next_primitive_renumber = 0;
  500.  
  501.     while (--number_of_primitives >= 0)
  502.       (*where++) = SHARP_F;
  503.   }
  504.   return (top);
  505. }
  506.  
  507. SCHEME_OBJECT
  508. DEFUN (dump_renumber_primitive, (primitive), fast SCHEME_OBJECT primitive)
  509. {
  510.   fast long number;
  511.   fast SCHEME_OBJECT result;
  512.  
  513.   number = PRIMITIVE_NUMBER(primitive);
  514.   result = internal_renumber_table[number];
  515.   if (result == SHARP_F)
  516.   {
  517.     result = (OBJECT_NEW_DATUM (primitive, next_primitive_renumber));
  518.     internal_renumber_table[number] = result;
  519.     external_renumber_table[next_primitive_renumber] = primitive;
  520.     next_primitive_renumber += 1;
  521.     return (result);
  522.   }
  523.   else
  524.   {
  525.     return (MAKE_OBJECT_FROM_OBJECTS (primitive, result));
  526.   }
  527. }
  528.  
  529. /* Is supposed to have a null character. */
  530. static char null_string [] = "";
  531.  
  532. SCHEME_OBJECT *
  533. DEFUN (copy_primitive_information, (code, start, end),
  534.        long code
  535.        AND fast SCHEME_OBJECT * start AND fast SCHEME_OBJECT * end)
  536. {
  537.   if (start < end)
  538.     (*start++) = (LONG_TO_FIXNUM (primitive_code_to_arity ((int) code)));
  539.   {
  540.     fast char * source = (primitive_code_to_name ((int) code));
  541.     SCHEME_OBJECT * saved = start;
  542.     start += STRING_CHARS;
  543.     {
  544.       fast char * dest = ((char *) start);
  545.       fast char * limit = ((char *) end);
  546.       if (source == ((char *) 0))
  547.     source = ((char *) (& (null_string [0])));
  548.       while ((dest < limit) && (((*dest++) = (*source++)) != '\0'))
  549.     ;
  550.       if (dest >= limit)
  551.     while ((*source++) != '\0')
  552.       dest += 1;
  553.       {
  554.     long char_count = ((dest - 1) - ((char *) start));
  555.     long word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count));
  556.     start = (saved + 1 + word_count);
  557.     if (start < end)
  558.       {
  559.         (saved [STRING_HEADER]) =
  560.           (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count));
  561.         (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count);
  562.       }
  563.     return (start);
  564.       }
  565.     }
  566.   }
  567. }
  568.  
  569. SCHEME_OBJECT *
  570. DEFUN (cons_primitive_table, (start, end, length),
  571.        SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND
  572.        long * length)
  573. {
  574.   SCHEME_OBJECT *saved;
  575.   long count, code;
  576.  
  577.   saved = start;
  578.   *length = next_primitive_renumber;
  579.  
  580.   for (count = 0;
  581.        ((count < next_primitive_renumber) && (start < end));
  582.        count += 1)
  583.   {
  584.     code = (PRIMITIVE_NUMBER(external_renumber_table[count]));
  585.     start = copy_primitive_information(code, start, end);
  586.   }
  587.   return (start);
  588. }
  589.  
  590. SCHEME_OBJECT *
  591. DEFUN (cons_whole_primitive_table, (start, end, length),
  592.        SCHEME_OBJECT * start AND SCHEME_OBJECT * end
  593.        AND long * length)
  594. {
  595.   SCHEME_OBJECT *saved;
  596.   long count, number_of_primitives;
  597.  
  598.   number_of_primitives = NUMBER_OF_PRIMITIVES();
  599.   *length = number_of_primitives;
  600.   saved = start;
  601.  
  602.   for (count = 0;
  603.        ((count < number_of_primitives) && (start < end));
  604.        count += 1)
  605.   {
  606.     start = copy_primitive_information(count, start, end);
  607.   }
  608.   return (start);
  609. }
  610.  
  611. void
  612. DEFUN (install_primitive_table, (table, length, flush_p),
  613.        fast SCHEME_OBJECT * table
  614.        AND fast long length
  615.        AND Boolean flush_p)
  616. {
  617.   fast SCHEME_OBJECT *translation_table;
  618.   SCHEME_OBJECT result;
  619.   long arity;
  620.  
  621.   if (flush_p)
  622.   {
  623.     Undefined_Primitives = SHARP_F;
  624.     Undefined_Primitives_Arity = SHARP_F;
  625.   }
  626.  
  627.   translation_table = load_renumber_table;
  628.   while (--length >= 0)
  629.   {
  630.     arity = FIXNUM_TO_LONG (*table);
  631.     table += 1;
  632.     result =
  633.       search_for_primitive(MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table),
  634.                ((char *) (&table[STRING_CHARS])),
  635.                true, true, arity);
  636.     if (OBJECT_TYPE (result) != TC_PRIMITIVE)
  637.     {
  638.       signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
  639.     }
  640.     *translation_table++ = result;
  641.     table += (1 + OBJECT_DATUM (*table));
  642.   }
  643.   return;
  644. }
  645.